home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swaga_c.zip / ARCHIVES.SWG / 0029_RDC Compression.pas < prev   
Pascal/Delphi Source File  |  1995-02-28  |  13KB  |  505 lines

  1.  
  2. {
  3. Well here it is as promised. This is a Pascal port of Ross
  4. Data compression. This particular unit does no buffer
  5. compression/decompression but you can add it if you want.
  6. The C implementation I did has Buffer to file compression
  7. and file to buffer decompression.
  8.  
  9. This is a freebie and is availble for SWAG if they
  10. want it.
  11.  
  12.  
  13. Common data types unit I use a lot. Looks like Delphi
  14. incorporated similar types.
  15.  
  16. }
  17. (*
  18.   Common data types and structures.
  19. *)
  20.  
  21. Unit Common;
  22. Interface
  23.  
  24. Type
  25.   PByte = ^Byte;
  26.   ByteArray = Array[0..65000] Of Byte;
  27.   PByteArray = ^ByteArray;
  28.  
  29.   PInteger = ^Integer;
  30.   IntArray = Array[0..32000] Of Integer;
  31.   PIntArray = ^IntArray;
  32.  
  33.   PWord = ^Word;
  34.   WordArray = Array[0..32000] Of Word;
  35.   PWordArray = ^WordArray;
  36.  
  37. Implementation
  38.  
  39. END.
  40.  
  41. (***************************************************
  42.  * RDC Unit                                        *
  43.  *                                                 *
  44.  * This is a Pascal port of C code from an article *
  45.  * In "The C Users Journal", 1/92 Written by       *
  46.  * Ed Ross.                                        *
  47.  *                                                 *
  48.  * This particular code has worked well under,     *
  49.  * Real, Protected and Windows.                    *
  50.  *                                                 *
  51.  * The compression is not quite as good as PKZIP   *
  52.  * but it decompresses about 5 times faster.       *
  53.  ***************************************************)
  54. Unit RDCUnit;
  55. Interface
  56. Uses
  57.   Common;
  58.  
  59. Procedure Comp_FileToFile(Var infile, outfile: File);
  60. Procedure Decomp_FileToFile(Var infile, outfile: File);
  61.  
  62. Implementation
  63. Const
  64.   HASH_LEN =  4096;    { # hash table entries }
  65.   HASH_SIZE = HASH_LEN * Sizeof(word);
  66.   BUFF_LEN = 16384;    { size of disk io buffer }
  67.  
  68.  
  69. (*
  70.  compress inbuff_len bytes of inbuff into outbuff
  71.  using hash_len entries in hash_tbl.
  72.  
  73.  return length of outbuff, or "0 - inbuff_len"
  74.  if inbuff could not be compressed.
  75. *)
  76. Function rdc_compress(ibuff      : Pointer;
  77.                       inbuff_len : Word;
  78.                       obuff      : Pointer;
  79.                       htable     : Pointer) : Integer;
  80. Var
  81.   inbuff      : PByte Absolute ibuff;
  82.   outbuff     : PByte Absolute obuff;
  83.   hash_tbl    : PWordArray Absolute htable;
  84.   in_idx      : PByte;
  85.   in_idxa     : PByteArray absolute in_idx;
  86.   inbuff_end  : PByte;
  87.   anchor      : PByte;
  88.   pat_idx     : PByte;
  89.   cnt         : Word;
  90.   gap         : Word;
  91.   c           : Word;
  92.   hash        : Word;
  93.   hashlen     : Word;
  94.   ctrl_idx    : PWord;
  95.   ctrl_bits   : Word;
  96.   ctrl_cnt    : Word;
  97.   out_idx     : PByte;
  98.   outbuff_end : PByte;
  99. Begin
  100.   in_idx := inbuff;
  101.   inbuff_end := Pointer(LongInt(inbuff) + inbuff_len);
  102.   ctrl_idx := Pointer(outbuff);
  103.   ctrl_cnt := 0;
  104.  
  105.   out_idx := Pointer(longint(outbuff) + Sizeof(Word));
  106.   outbuff_end := Pointer(LongInt(outbuff) + (inbuff_len - 48));
  107.  
  108.   { skip the compression for a small buffer }
  109.  
  110.   If inbuff_len <= 18 Then
  111.   Begin
  112.     Move(outbuff, inbuff, inbuff_len);
  113.     rdc_compress := 0 - inbuff_len;
  114.     Exit;
  115.   End;
  116.  
  117.   { adjust # hash entries so hash algorithm can
  118.     use 'and' instead of 'mod' }
  119.  
  120.   hashlen := HASH_LEN - 1;
  121.  
  122.   { scan thru inbuff }
  123.  
  124.   While LongInt(in_idx) < LongInt(inbuff_end) Do
  125.   Begin
  126.     { make room for the control bits
  127.       and check for outbuff overflow }
  128.  
  129.     If ctrl_cnt = 16 Then
  130.     Begin
  131.       ctrl_idx^ := ctrl_bits;
  132.       ctrl_cnt := 1;
  133.       ctrl_idx := Pointer(out_idx);
  134.       Inc(word(out_idx), 2);
  135.       If LongInt(out_idx) > LongInt(outbuff_end) Then
  136.       Begin
  137.         Move(outbuff, inbuff, inbuff_len);
  138.         rdc_compress := inbuff_len;
  139.         Exit;
  140.       End;
  141.     End
  142.     Else
  143.       Inc(ctrl_cnt);
  144.  
  145.       { look for rle }
  146.  
  147.       anchor := in_idx;
  148.       c := in_idx^;
  149.       Inc(in_idx);
  150.  
  151.       While (LongInt(in_idx) < longint(inbuff_end))
  152.             And (in_idx^ = c)
  153.             And (LongInt(in_idx) - LongInt(anchor) < (HASH_LEN + 18)) Do
  154.         Inc(in_idx);
  155.  
  156.       { store compression code if character is
  157.         repeated more than 2 times }
  158.  
  159.       cnt := LongInt(in_idx) - LongInt(anchor);
  160.       If cnt > 2 Then
  161.       Begin
  162.         If cnt <= 18 Then     { short rle }
  163.         Begin
  164.           out_idx^ := cnt - 3;
  165.           Inc(out_idx);
  166.           out_idx^ := c;
  167.           Inc(out_idx);
  168.         End
  169.         Else                    { long rle }
  170.         Begin
  171.           Dec(cnt, 19);
  172.           out_idx^ := 16 + (cnt and $0F);
  173.           Inc(out_idx);
  174.           out_idx^ := cnt Shr 4;
  175.           Inc(out_idx);
  176.           out_idx^ := c;
  177.           Inc(out_idx);
  178.         End;
  179.  
  180.         ctrl_bits := (ctrl_bits Shl 1) Or 1;
  181.         Continue;
  182.       End;
  183.  
  184.       { look for pattern if 2 or more characters
  185.         remain in the input buffer }
  186.  
  187.       in_idx := anchor;
  188.  
  189.       If (LongInt(inbuff_end) - LongInt(in_idx)) > 2 Then
  190.       Begin
  191.         { locate offset of possible pattern
  192.           in sliding dictionary }
  193.  
  194.         hash := ((((in_idxa^[0] And 15) Shl 8) Or in_idxa^[1]) Xor
  195.                  ((in_idxa^[0] Shr 4) Or (in_idxa^[2] Shl 4)))
  196.                  And hashlen;
  197.  
  198.         pat_idx := in_idx;
  199.         Word(pat_idx) := hash_tbl^[hash];
  200.         hash_tbl^[hash] := Word(in_idx);
  201.  
  202.         { compare characters if we're within 4098 bytes }
  203.  
  204.         gap := LongInt(in_idx) - LongInt(pat_idx);
  205.         If (gap <= HASH_LEN + 2) Then
  206.         Begin
  207.           While (LongInt(in_idx) < LongInt(inbuff_end))
  208.                 And (LongInt(pat_idx) < LongInt(anchor))
  209.                 And (pat_idx^ = in_idx^)
  210.                 And (LongInt(in_idx) - LongInt(anchor) < 271) Do
  211.           Begin
  212.             Inc(in_idx);
  213.             Inc(pat_idx);
  214.           End;
  215.  
  216.           { store pattern if it is more than 2 characters }
  217.  
  218.           cnt := LongInt(in_idx) - LongInt(anchor);
  219.           If cnt > 2 Then
  220.           Begin
  221.             Dec(gap, 3);
  222.  
  223.             If cnt <= 15 Then     { short pattern }
  224.             Begin
  225.               out_idx^ := (cnt Shl 4) + (gap And $0F);
  226.               Inc(out_idx);
  227.               out_idx^ := gap Shr 4;
  228.               Inc(out_idx);
  229.             End
  230.             Else                    { long pattern }
  231.             Begin
  232.               out_idx^ := 32 + (gap And $0F);
  233.               Inc(out_idx);
  234.               out_idx^ := gap Shr 4;
  235.               Inc(out_idx);
  236.               out_idx^ := cnt - 16;
  237.               Inc(out_idx);
  238.             End;
  239.  
  240.             ctrl_bits := (ctrl_bits Shl 1) Or 1;
  241.             Continue;
  242.           End;
  243.         End;
  244.       End;
  245.  
  246.       { can't compress this character
  247.         so copy it to outbuff }
  248.  
  249.       out_idx^ := c;
  250.       Inc(out_idx);
  251.       Inc(anchor);
  252.       in_idx := anchor;
  253.       ctrl_bits := ctrl_bits Shl 1;
  254.   End;
  255.  
  256.   { save last load of control bits }
  257.  
  258.   ctrl_bits := ctrl_bits Shl (16 - ctrl_cnt);
  259.   ctrl_idx^ := ctrl_bits;
  260.  
  261.   { and return size of compressed buffer }
  262.  
  263.   rdc_compress := LongInt(out_idx) - LongInt(outbuff);
  264. End;
  265.  
  266. (*
  267.  decompress inbuff_len bytes of inbuff into outbuff.
  268.  
  269.  return length of outbuff.
  270. *)
  271. Function RDC_Decompress(inbuff     : PByte;
  272.                         inbuff_len : Word;
  273.                         outbuff    : PByte) : Integer;
  274. Var
  275.   ctrl_bits    : Word;
  276.   ctrl_mask    : Word;
  277.   inbuff_idx   : PByte;
  278.   outbuff_idx  : PByte;
  279.   inbuff_end   : PByte;
  280.   cmd, cnt     : Word;
  281.   ofs, len     : Word;
  282.   outbuff_src  : PByte;
  283. Begin
  284.   ctrl_mask := 0;
  285.   inbuff_idx := inbuff;
  286.   outbuff_idx := outbuff;
  287.   inbuff_end := Pointer(LongInt(inbuff) + inbuff_len);
  288.  
  289.   { process each item in inbuff }
  290.   While LongInt(inbuff_idx) < LongInt(inbuff_end) Do
  291.   Begin
  292.     { get new load of control bits if needed }
  293.     ctrl_mask := ctrl_mask Shr 1;
  294.     If ctrl_mask = 0 Then
  295.     Begin
  296.       ctrl_bits := PWord(inbuff_idx)^;
  297.       Inc(inbuff_idx, 2);
  298.       ctrl_mask := $8000;
  299.     End;
  300.  
  301.     { just copy this char if control bit is zero }
  302.     If (ctrl_bits And ctrl_mask) = 0 Then
  303.     Begin
  304.       outbuff_idx^ := inbuff_idx^;
  305.       Inc(outbuff_idx);
  306.       Inc(inbuff_idx);
  307.       Continue;
  308.     End;
  309.  
  310.     { undo the compression code }
  311.     cmd := (inbuff_idx^ Shr 4) And $0F;
  312.     cnt := inbuff_idx^ And $0F;
  313.     Inc(inbuff_idx);
  314.  
  315.     Case cmd Of
  316.       0 :     { short rle }
  317.       Begin
  318.         Inc(cnt, 3);
  319.         FillChar(outbuff_idx^, cnt, inbuff_idx^);
  320.         Inc(inbuff_idx);
  321.         Inc(outbuff_idx, cnt);
  322.       End;
  323.  
  324.       1 :     { long rle }
  325.       Begin
  326.         Inc(cnt,  inbuff_idx^ Shl 4);
  327.         Inc(inbuff_idx);
  328.         Inc(cnt, 19);
  329.         FillChar(outbuff_idx^, cnt, inbuff_idx^);
  330.         Inc(inbuff_idx);
  331.         Inc(outbuff_idx, cnt);
  332.       End;
  333.  
  334.       2 :     { long pattern }
  335.       Begin
  336.         ofs := cnt + 3;
  337.         Inc(ofs, inbuff_idx^ Shl 4);
  338.         Inc(inbuff_idx);
  339.         cnt := inbuff_idx^;
  340.         Inc(inbuff_idx);
  341.         Inc(cnt, 16);
  342.         outbuff_src := Pointer(LongInt(outbuff_idx) - ofs);
  343.         Move(outbuff_src^, outbuff_idx^, cnt);
  344.         Inc(outbuff_idx, cnt);
  345.       End;
  346.  
  347.       Else    { short pattern}
  348.       Begin
  349.         ofs := cnt + 3;
  350.         Inc(ofs, inbuff_idx^ Shl 4);
  351.         Inc(inbuff_idx);
  352.         outbuff_src := Pointer(LongInt(outbuff_idx) - ofs);
  353.         Move(outbuff_src^, outbuff_idx^, cmd);
  354.         Inc(outbuff_idx, cmd);
  355.       End;
  356.     End;
  357.   End;
  358.  
  359.   { return length of decompressed buffer }
  360.   RDC_Decompress := LongInt(outbuff_idx) - LongInt(outbuff);
  361. End;
  362.  
  363. Procedure Comp_FileToFile(Var infile, outfile: File);
  364. Var
  365.   code         : Integer;
  366.   bytes_read   : Integer;
  367.   compress_len : Integer;
  368.   HashPtr      : PWordArray;
  369.   inputbuffer,
  370.   outputbuffer : PByteArray;
  371. Begin
  372.   Getmem(HashPtr, HASH_SIZE);
  373.   Fillchar(hashPtr^, HASH_SIZE, #0);
  374.   Getmem(inputbuffer, BUFF_LEN);
  375.   Getmem(outputbuffer, BUFF_LEN);
  376.  
  377.   { read infile BUFF_LEN bytes at a time }
  378.  
  379.   bytes_read := BUFF_LEN;
  380.   While bytes_read = BUFF_LEN Do
  381.   Begin
  382.     Blockread(infile, inputbuffer^, BUFF_LEN, bytes_read);
  383.  
  384.     { compress this load of bytes }
  385.     compress_len := RDC_Compress(PByte(inputbuffer), bytes_read,
  386.                                  PByte(outputbuffer), HashPtr);
  387.  
  388.     { write length of compressed buffer }
  389.     Blockwrite(outfile, compress_len, 2, code);
  390.  
  391.     { check for negative length indicating the buffer could not be compressed }
  392.     If compress_len < 0 Then
  393.       compress_len := 0 - compress_len;
  394.  
  395.     { write the buffer }
  396.     Blockwrite(outfile, outputbuffer^, compress_len, code);
  397.     { we're done if less than full buffer was read }
  398.   End;
  399.  
  400.   { add trailer to indicate End of File }
  401.   compress_len := 0;
  402.   Blockwrite(outfile, compress_len, 2, code);
  403.   {
  404.   If (code <> 2) then
  405.      err_exit('Error writing trailer.'+#13+#10);
  406.   }
  407.   Freemem(HashPtr, HASH_SIZE);
  408.   Freemem(inputbuffer, BUFF_LEN);
  409.   Freemem(outputbuffer, BUFF_LEN);
  410. End;
  411.  
  412. Procedure Decomp_FileToFile(Var infile, outfile: File);
  413. Var
  414.   code         : Integer;
  415.   block_len    : Integer;
  416.   decomp_len   : Integer;
  417.   HashPtr      : PWordArray;
  418.   inputbuffer,
  419.   outputbuffer : PByteArray;
  420. Begin
  421.   Getmem(inputbuffer, BUFF_LEN);
  422.   Getmem(outputbuffer, BUFF_LEN);
  423.   { read infile BUFF_LEN bytes at a time }
  424.   block_len := 1;
  425.   While block_len <> 0 do
  426.   Begin
  427.     Blockread(infile, block_len, 2, code);
  428.     {
  429.     If (code <> 2) then
  430.       err_exit('Can''t read block length.'+#13+#10);
  431.     }
  432.     { check for End-of-file flag }
  433.     If block_len <> 0 Then
  434.     Begin
  435.       If (block_len < 0) Then { copy uncompressed chars }
  436.       Begin
  437.         decomp_len := 0 - block_len;
  438.         Blockread(infile, outputbuffer^, decomp_len, code);
  439.         {
  440.         If code <> decomp_len) then
  441.           err_exit('Can''t read uncompressed block.'+#13+#10);
  442.         }
  443.       End
  444.       Else                { decompress this buffer }
  445.       Begin
  446.         Blockread(infile, inputbuffer^, block_len, code);
  447.         {
  448.         If (code <> block_len) then
  449.           err_exit('Can''t read compressed block.'+#13+#10);
  450.         }
  451.         decomp_len := RDC_Decompress(PByte(inputbuffer), block_len,
  452.                                      PByte(outputbuffer));
  453.       End;
  454.       { and write this buffer outfile }
  455.       Blockwrite(outfile, outputbuffer^, decomp_len, code);
  456.       {
  457.       if (code <> decomp_len) then
  458.         err_exit('Error writing uncompressed data.'+#13+#10);
  459.       }
  460.     End;
  461.   End;
  462.  
  463.   Freemem(inputbuffer, BUFF_LEN);
  464.   Freemem(outputbuffer, BUFF_LEN);
  465. End;
  466.  
  467. END.
  468.  
  469. <------------------- CUT ------------------------->
  470.  
  471. Here is the test program I used to test this. You will
  472. have to change it to reflect other file names but it
  473. will give you an idea of how to use the unit.
  474.  
  475. <------------------- CUT ------------------------->
  476. Program RDCTest;
  477. Uses
  478.   RDCUnit;
  479.  
  480. Var
  481.   fin, fout : File;
  482.   a         : Array[0..50] Of Byte;
  483.  
  484. BEGIN
  485. {
  486.   Assign(fin, 'ASMINTRO.TXT');
  487.   Reset(fin, 1);
  488.  
  489.   Assign(fout, 'ASMINTRO.RDC');
  490.   Rewrite(fout, 1);
  491.  
  492.   Comp_FileToFile(fin, fout);
  493. }
  494.   Assign(fin, 'ASMINTRO.RDC');
  495.   Reset(fin, 1);
  496.  
  497.   Assign(fout, 'ASMINTRO.2');
  498.   Rewrite(fout, 1);
  499.  
  500.   Decomp_FileToFile(fin, fout);
  501.  
  502.   Close(fin);
  503.   Close(fout);
  504. END.
  505.